home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
TSR
/
STAY50
/
SR50SUBS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-11-28
|
20KB
|
474 lines
{$I direct.inc}
{────────────────────────────────────────────────────────────────────────────}
{ SR50Subs.Pas }
{ }
{ Copyright (c) 1988 Lane H. Ferris }
{────────────────────────────────────────────────────────────────────────────}
unit SR50Subs ;
{────────────────────────────────────────────────────────────────────────}
interface
{────────────────────────────────────────────────────────────────────────}
uses dos,crt ;
const
Haltlevel = 1 ; { Error msg action levels }
Warnlevel = 2 ;
Infolevel = 4 ;
type
lcstringtype = string[255] ;
string4 = string[4] ;
string9 = string[9] ;
var
DosVersion : byte ; { Current Version of DOS }
DosCriticalStatus : pointer ; { Dos Critical Status byte ptr }
InDosStatus : pointer ; { Dos Active status byte ptr }
InDosStackptr : pointer ; { ofs within Dos of InDos stack }
Procedure Caps (var lcstring : string) ;
Procedure ErrorMsg ( SeverityLevel : integer ; Message : string) ;
Procedure GetDTA ( var DTAvector : pointer ) ;
Procedure GetPSP ( var segment : word ) ;
Function Hexword ( hexint:word) :string4 ;
Function HexPtr ( hexinptr :pointer) :string9 ;
Procedure BorderWindow (xlo,ylo,xhi,yhi : byte; border : boolean) ;
Function PtrDiff (Ptr1, Ptr2 : pointer ) : longint ;
Procedure RestoreWindow(xlo,ylo,xhi,yhi :integer ;pwindowptr :pointer) ;
Procedure SaveWindow(xlo,ylo,xhi,yhi :integer ;var windowptr :pointer) ;
Procedure SetDTA ( DTAvector : pointer ) ;
Procedure SetPSP ( var segment : word ) ;
Function UpperCase(var lcstring :lcstringtype) :lcstringtype;
{────────────────────────────────────────────────────────────────────────}
implementation
{────────────────────────────────────────────────────────────────────────}
uses macros ,
SR50 ;
TYPE
String2 = string[2] ;
string80 = string[80] ;
CONST
carry = 1 ; {carry flag in Flag register}
{('╒', '═', '╕', '└', '─', '┘', '│')}
borderchars: array[1..7] of word = (213, 205, 184, 192, 196, 217, 179);
var
videobuf : word ;
{──────────────────────────────────────────────────────────────────}
{ Caps }
{──────────────────────────────────────────────────────────────────}
{ convert string to upper case }
{──────────────────────────────────────────────────────────────────}
Procedure Caps(var lcstring:string) ;
var
i :integer ;
begin
for i := 1 to length(lcstring) do
lcstring[i] := upcase(lcstring[i]) ;
End { Caps } ;
{──────────────────────────────────────────────────────────────────}
{ PtrDiff }
{──────────────────────────────────────────────────────────────────}
{ Returns byte difference in pointers }
{──────────────────────────────────────────────────────────────────}
FUNCTION PtrDiff(Ptr1, Ptr2 : pointer ) : longint ;
var
tmpwrd : longint ;
BEGIN
tmpwrd := ( vec(ptr1).seg - vec(ptr2).seg ) shl 4 ;
tmpwrd := tmpwrd + ( vec(ptr1).ofs - vec(ptr2).ofs ) ;
PtrDiff := tmpwrd ;
END;
{─────────────────────────────────────────────────────────}
{ SET DTA }
{─────────────────────────────────────────────────────────}
Procedure SetDTA(DTAvector : pointer );
var
regs : registers ;
BEGIN
regs.ax := $1A00 ; { get current DTA function }
regs.Ds := vec(DTAvector).seg ; { Segment of DTA returned by DOS }
regs.Dx := vec(DTAvector).ofs ; { Offset of DTA returned }
intr($21,regs) ;
END;
{─────────────────────────────────────────────────────────}
{ G E T D T A }
{─────────────────────────────────────────────────────────}
Procedure GetDTA(var DTAvector : pointer );
VAR regs : registers;
BEGIN
regs.ax := $2F00 ; { get current DTA address }
intr($21, regs ) ; { Execute MSDos function }
vec(DTAvector).seg := regs.ES; { DTA segment from DOS }
vec(DTAvector).ofs := regs.Bx; { DTA Offset returned }
END;
{─────────────────────────────────────────────────────────}
{ S E T P S P }
{─────────────────────────────────────────────────────────}
Procedure SetPSP(var segment : word );
var
regs : registers ;
BEGIN
{ A bug in DOS 2.0, 2.1, causes DOS to clobber its standard stack }
{ when the PSP get/set functions are issued at the DOS prompt. The }
{ following checks are made, forcing DOS to use the "critical" }
{ stack when the TSR enters at the INDOS level. }
{If Version less then 3.0 and INDOS set }
If DosVersion < 3 then { then set the Dos Critical Flag }
IF ( byte(DosCriticalStatus^) or
byte(InDosStatus^) ) = 0 then {ok}
else byte(DosCriticalStatus^) := $FF ;
regs.ax := $5000 ; { Function to set new PSP address }
regs.bx := segment ; { Segment of PSP returned by DOS }
Intr($21, regs) ; { Execute MSDos function request }
{ If Version less then 3.0 and INDOS on }
If DosVersion < 3 then { then clear the Dos Critical Flag }
IF ( byte(DosCriticalStatus^) or
byte(InDosStatus^) ) = 0 then {}
else byte(DosCriticalStatus^) := $00 ;
END;
{─────────────────────────────────────────────────────────}
{ G E T P S P }
{─────────────────────────────────────────────────────────}
Procedure GetPSP(var segment : word );
var
regs : registers ;
BEGIN
{ A bug in DOS 2.0, 2.1, causes DOS to clobber its standard stack }
{ when the PSP get/set functions are issued at the DOS prompt. The }
{ following checks are made, forcing DOS to use the "critical" }
{ stack when the TSR enters at the INDOS level. }
{If Version less then 3.0 and INDOS set }
If DosVersion < 3 then { then set the Dos Critical Flag }
IF ( byte(DosCriticalStatus^) or
byte(InDosStatus^) ) = 0 then {ok}
else byte(DosCriticalStatus^) := $FF ;
regs.ax := $5100 ; { Function to get current PSP address }
intr($21,regs ) ; { Execute MSDos function request }
segment := regs.Bx ; { Segment of PSP returned by DOS }
{IF DOS Version less then 3.0 and INDOS set }
If DosVersion < 3 then { then clear the Dos Critical Flag }
IF ( byte(DosCriticalStatus^) or
byte(InDosStatus^) ) = 0 then {}
else byte(DosCriticalStatus^) := $00 ;
END;
{───────────────────────────────────────────────────────────────}
{ G e t C o n t r o l C (break) V e c t o r }
{───────────────────────────────────────────────────────────────}
Type
Arrayparam = array [1..2] of integer;
Const
SavedCtlC: arrayparam = (0,0);
NewCtlC : arrayparam = (0,0);
Procedure GetCtlC(Var SavedCtlC:arrayparam);
var
regs : registers ;
Begin {Record the Current Ctrl-C Vector}
With Regs Do
Begin
AX := $3523 ;
intr($21,Regs) ;
SavedCtlC[1] := BX ;
SavedCtlC[2] := ES ;
End ;
End;
{───────────────────────────────────────────────────────────────}
{ S e t C o n t r o l C V e c t o r }
{───────────────────────────────────────────────────────────────}
Procedure SetCtlC(Var CtlCptr:arrayparam);
var
regs : registers ;
Begin {Set the New Ctrl-C Vector}
With Regs Do
Begin
AX := $2523 ;
DS := CtlCptr[2] ;
DX := CtlCptr[1] ;
intr($21,Regs) ;
End ;
End ;
{─────────────────────────────────────────────────────────}
{ U p p e r C a s e of string }
{─────────────────────────────────────────────────────────}
Function UpperCase(var lcstring :lcstringtype) :lcstringtype;
VAR
i :integer;
Begin
for i := 1 to ord(lcstring[0]) do
lcstring[i] := upcase(lcstring[i]);
UpperCase := lcstring;
end{uppercase};
{─────────────────────────────────────────────────────────}
{ HexByte B y t e t o A s c i i }
{─────────────────────────────────────────────────────────}
Function Hexbyte(hexint:byte) :string2;
CONST
Hexchars: array[0..15] of char =('0','1','2','3','4','5','6','7','8','9',
'A','B','C','D','E','F');
VAR
i :integer;
tempstring :string2;
BEGIN {Hexbyte}
tempstring[0] := #2; {force string length of two}
For i := 1 to 2 do
tempstring[i] := Hexchars[ hexint shr (4*(2-i)) and $0F ];
Hexbyte := tempstring;
END {Hexbyte};
{─────────────────────────────────────────────────────────}
{ HexWord H e x t o A s c i i }
{─────────────────────────────────────────────────────────}
Function Hexword(hexint:word) :string4;
CONST
Hexchars: array[0..15] of char =('0','1','2','3','4','5','6','7','8','9',
'A','B','C','D','E','F');
VAR
i :integer;
tempstring :string4;
BEGIN {Hexword}
tempstring[0] := #4; {force string length of four}
For i := 1 to 4 do
tempstring[i] := Hexchars[ hexint shr (4*(4-i)) and $000F ];
Hexword := tempstring;
END {Hexword};
{───────────────────────────────────────────────────────────}
{ HexPtr }
{───────────────────────────────────────────────────────────}
Function HexPtr(hexinptr :pointer) :string9;
CONST
Hexchars: array[0..15] of char =('0','1','2','3','4','5','6','7','8','9',
'A','B','C','D','E','F');
var
ptrin : vector absolute hexinptr ;
i :integer;
tempstring :string9;
BEGIN {HexPtr}
tempstring[0] := #9; {force string length of nine}
For i := 1 to 4 do
tempstring[i] := Hexchars[ ptrin.seg shr (4*(4-i)) and $000F ];
tempstring[5] := '.' ;
For i := 6 to 9 do
tempstring[i] := Hexchars[ ptrin.ofs shr (4*(9-i)) and $000F ];
HexPtr := tempstring ;
END {HexPtr};
{──────────────────────────────────────────────────────────────────}
{ Error Msg }
{──────────────────────────────────────────────────────────────────}
Procedure ErrorMsg ( SeverityLevel : integer ;
Message : string ) ;
var
oldx,oldy : byte ;
Begin
resource(reserve,_CRT) ;
Oldx := wherex ; { save cursor position }
Oldy := wherey ;
Gotoxy(1,1) ; { message on top line }
writeln ( Message ) ; { write message to crt }
if SeverityLevel = HaltLevel then begin
write(^G,'Sever Error, Halting Program') ;
Halt(SeverityLevel) ;
end ;
Gotoxy(Oldx,Oldy) ; { return cursor }
resource(rlse,_CRT) ;
End {ErrorMsg} ;
{───────────────────────────────────────────────────────────}
{ SaveWindow }
{───────────────────────────────────────────────────────────}
Procedure SaveWindow(xlo,ylo,xhi,yhi :integer ;
var windowptr :pointer) ;
var
xlth,ylth : integer ;
windowsize : integer ;
videoofs : word ;
i : integer ;
BEGIN
xlth := xhi-xlo+1 ; { from old SRB window }
ylth := yhi-ylo+1 ;
windowsize := ((xhi-xlo+1)*(yhi-ylo+1))*2 ;
getmem(windowptr,windowsize) ;
Videoofs := ((ylo-1)*80 + (xlo-1))*2 ;
push(vec(windowptr).ofs) ; { save window }
for i := 0 to ylth-1 do begin
move( ptr(Videoseg,Videoofs+i*160)^, windowptr^, xlth*2) ;
incptr(windowptr,xlth*2) ;
end ;
pop(vec(windowptr).ofs) ;
End { SaveWindow } ;
{───────────────────────────────────────────────────────────}
{ RestoreWindow }
{───────────────────────────────────────────────────────────}
Procedure RestoreWindow(xlo,ylo,xhi,yhi :integer ;
pwindowptr :pointer) ;
var
xlth,ylth : integer ;
windowptr : pointer ;
windowsize : integer ;
videoofs : word ;
i : integer ;
Begin
windowsize := ((xhi-xlo+1)*(yhi-ylo+1))*2 ;
windowptr := pwindowptr ;
xlth := xhi-xlo+1 ;
ylth := yhi-ylo+1 ;
Videoofs := ((ylo-1)*80 + (xlo-1))*2 ;
push(vec(windowptr).ofs) ;
for i := 0 to ylth-1 do begin
move(windowptr^,ptr(Videoseg,Videoofs+i*160)^,xlth*2) ;
incptr(windowptr,xlth*2) ;
end ;
pop(vec(windowptr).ofs) ;
freemem(windowptr,windowsize) ;
End {Restore Window} ;
{───────────────────────────────────────────────────────────}
{ BorderWindow }
{───────────────────────────────────────────────────────────}
Procedure BorderWindow (xlo,ylo,xhi,yhi : byte; border : boolean) ;
var
i : integer ;
xlth,ylth : integer ;
windowsize : integer ;
videoofs : word ;
BEGIN {BorderWindow}
xlth := xhi-xlo+1 ;
ylth := yhi-ylo+1 ;
windowsize := ((xhi-xlo+1)*(yhi-ylo+1))*2 ;
Videoofs := ((ylo-1)*80 + (xlo-1))*2 ;
crt.Window(xlo,ylo,xhi,yhi) ; { make a new window }
if Border then begin
for i := 0 to xlth-1 do { top border }
move( borderchars[2], ptr(videobuf,Videoofs+i*2)^, 2) ;
move( borderchars[1], ptr(videobuf,Videoofs)^, 2) ;
move( borderchars[3], ptr(videobuf,Videoofs+(xlth-1)*2)^, 2) ;
push(Videoofs) ;
Videoofs := Videoofs+(ylth-1)*160 ;
for i := 0 to xlth-1 do { bottom border }
move( borderchars[5], ptr(videobuf,Videoofs+i*2)^, 2) ;
move( borderchars[4], ptr(videobuf,Videoofs)^, 2) ;
move( borderchars[6], ptr(videobuf,Videoofs+(xlth-1)*2)^, 2) ;
pop(Videoofs) ;
push(Videoofs) ;
Videoofs := Videoofs+160 ; { side borders }
for i := 1 to ylth-2 do begin
move( borderchars[7], ptr(videobuf,Videoofs)^, 2) ;
move( borderchars[7], ptr(videobuf,Videoofs+(xlth-1)*2)^,2) ;
inc(Videoofs,160) ;
end ;
pop(Videoofs) ;
crt.window(xlo+1,ylo+1,xhi-1,yhi-1) ; { move inside border }
end {if border } ;
clrscr ;
END {BorderWindow};
{─────────────────────────────────────────────────────────────────}
{ initialization }
{─────────────────────────────────────────────────────────────────}
var
regs : registers ;
byteptr : pointer ;
FoundInDosStack : boolean ;
i : integer ;
begin { unit initialization }
{DosVersion must be initialized before PSP and DTA calls }
With regs do BEGIN
Ax := $3000 ; { Obtain the DOS Version number }
Intr($21,Regs) ;
DosVersion := Al ; { 0=1+, 2=2.0+, 3=3.0+ }
Ah := $34 ; { get Dos Critical flag ptr }
Intr($21, regs ) ; { and InDos status flag ptr }
InDosStatus := ptr( ES,BX) ; { Dos 2.1, 3.1, 3.2 }
DosCriticalStatus := ptr( ES,BX-1) ; { .. not true of 3.0 }
END {with} ;
{───────────────────────────────────────────────────────────────}
{ Search for Dos instruction that contains the INDOS stack addr }
{ and the location of the critical flag. The critcal flag }
{ is NOT always in the word containing the InDosFlag. }
{ esp. in Ver 3.0 . Search for instructions : }
{ cmp [CriticalFlag],00 }
{ Jnz ... }
{ Mov SP,IndosStackOfs }
{───────────────────────────────────────────────────────────────}
Byteptr := InDosStatus ; { Search for instruction ... }
FoundInDosStack := false ; { CMP [critical flag],00 }
{ Mov SP,stackaddr }
While (vec(Byteptr).ofs < $2000)
and (FoundInDosStack = false ) do begin
if (word(Byteptr^) = $3E80) then { Cmp byte ptr : CMP instctn }
{ found CMP instructn }
{ is next byte MOV SP,xx }
If byte(ptr(vec(Byteptr).seg, { we have INDOS stack @ }
vec(Byteptr).ofs+7)^) = $BC
then BEGIN { InDos Stack address }
vec(DosCriticalStatus).ofs := { get Crit. flag ofs }
word(ptr(vec(Byteptr).seg,
vec(byteptr).ofs+2)^) ;
InDosStackptr := byteptr ; { set Stackptr segment }
vec(InDosStackptr).ofs :=
word(ptr(vec(byteptr).seg, { fetch true offset }
vec(byteptr).ofs+8)^) ;
FoundInDosStack := true ;
END{if byte..begin} ;
incptr(Byteptr,1) ; { examine next byte }
end{while bytptr < $2000} ;
{ Couldn't find critical flag CMP instruction or INDOS stack addr }
If FoundInDosStack then {ok} else begin
Writeln('SR50 cannot find critical/stack instructions') ;
Writeln('SR50 incompatiblity with Operating System') ;
Writeln('SR50 will not install correctly..Halting') ;
Halt; end;
for i := 1 to sizeof(borderchars) shr 1 do { add attributes to array of }
borderchars[i] := borderchars[i] or $0700 ; { border making words }
if Lastmode = mono then videobuf := $b000
else videobuf := $B800 ;
end { unit initialization } .